home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclCmdIL.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  81.3 KB  |  2,901 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclCmdIL.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    I through L.  It contains only commands in the generic core
  7.  *    (i.e. those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright (c) 1987-1993 The Regents of the University of California.
  10.  * Copyright (c) 1993-1997 Lucent Technologies.
  11.  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  *
  16.  * SCCS: @(#) tclCmdIL.c 1.168 97/07/29 12:52:40
  17.  */
  18.  
  19. #include "tclInt.h"
  20. #include "tclPort.h"
  21.  
  22. /*
  23.  * The following variable holds the full path name of the binary
  24.  * from which this application was executed, or NULL if it isn't
  25.  * know.  The value of the variable is set by the procedure
  26.  * Tcl_FindExecutable.  The storage space is dynamically allocated.
  27.  */
  28.  
  29. char *tclExecutableName = NULL;
  30.  
  31. /*
  32.  * During execution of the "lsort" command, structures of the following
  33.  * type are used to arrange the objects being sorted into a collection
  34.  * of linked lists.
  35.  */
  36.  
  37. typedef struct SortElement {
  38.     Tcl_Obj *objPtr;            /* Object being sorted. */
  39.     struct SortElement *nextPtr;        /* Next element in the list, or
  40.                      * NULL for end of list. */
  41. } SortElement;
  42.  
  43. /*
  44.  * The "lsort" command needs to pass certain information down to the
  45.  * function that compares two list elements, and the comparison function
  46.  * needs to pass success or failure information back up to the top-level
  47.  * "lsort" command.  The following structure is used to pass this
  48.  * information.
  49.  */
  50.  
  51. typedef struct SortInfo {
  52.     int isIncreasing;        /* Nonzero means sort in increasing order. */
  53.     int sortMode;        /* The sort mode.  One of SORTMODE_*
  54.                  * values defined below */
  55.     Tcl_DString compareCmd;    /* The Tcl comparison command when sortMode
  56.                  * is SORTMODE_COMMAND.  Pre-initialized to
  57.                  * hold base of command.*/
  58.     int index;            /* If the -index option was specified, this
  59.                  * holds the index of the list element
  60.                  * to extract for comparison.  If -index
  61.                  * wasn't specified, this is -1. */
  62.     Tcl_Interp *interp;        /* The interpreter in which the sortis
  63.                  * being done. */
  64.     int resultCode;        /* Completion code for the lsort command.
  65.                  * If an error occurs during the sort this
  66.                  * is changed from TCL_OK to  TCL_ERROR. */
  67. } SortInfo;
  68.  
  69. /*
  70.  * The "sortMode" field of the SortInfo structure can take on any of the
  71.  * following values.
  72.  */
  73.  
  74. #define SORTMODE_ASCII      0
  75. #define SORTMODE_INTEGER    1
  76. #define SORTMODE_REAL       2
  77. #define SORTMODE_COMMAND    3
  78. #define SORTMODE_DICTIONARY 4
  79.  
  80. /*
  81.  * Forward declarations for procedures defined in this file:
  82.  */
  83.  
  84. static int        DictionaryCompare _ANSI_ARGS_((char *left,
  85.                 char *right));
  86. static int        InfoArgsCmd _ANSI_ARGS_((ClientData dummy,
  87.                 Tcl_Interp *interp, int objc,
  88.                 Tcl_Obj *CONST objv[]));
  89. static int        InfoBodyCmd _ANSI_ARGS_((ClientData dummy,
  90.                 Tcl_Interp *interp, int objc,
  91.                 Tcl_Obj *CONST objv[]));
  92. static int        InfoCmdCountCmd _ANSI_ARGS_((ClientData dummy,
  93.                 Tcl_Interp *interp, int objc,
  94.                 Tcl_Obj *CONST objv[]));
  95. static int        InfoCommandsCmd _ANSI_ARGS_((ClientData dummy,
  96.                 Tcl_Interp *interp, int objc,
  97.                 Tcl_Obj *CONST objv[]));
  98. static int        InfoCompleteCmd _ANSI_ARGS_((ClientData dummy,
  99.                 Tcl_Interp *interp, int objc,
  100.                 Tcl_Obj *CONST objv[]));
  101. static int        InfoDefaultCmd _ANSI_ARGS_((ClientData dummy,
  102.                 Tcl_Interp *interp, int objc,
  103.                 Tcl_Obj *CONST objv[]));
  104. static int        InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
  105.                 Tcl_Interp *interp, int objc,
  106.                 Tcl_Obj *CONST objv[]));
  107. static int        InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
  108.                 Tcl_Interp *interp, int objc,
  109.                 Tcl_Obj *CONST objv[]));
  110. static int        InfoHostnameCmd _ANSI_ARGS_((ClientData dummy,
  111.                 Tcl_Interp *interp, int objc,
  112.                 Tcl_Obj *CONST objv[]));
  113. static int        InfoLevelCmd _ANSI_ARGS_((ClientData dummy,
  114.                 Tcl_Interp *interp, int objc,
  115.                 Tcl_Obj *CONST objv[]));
  116. static int        InfoLibraryCmd _ANSI_ARGS_((ClientData dummy,
  117.                 Tcl_Interp *interp, int objc,
  118.                 Tcl_Obj *CONST objv[]));
  119. static int        InfoLoadedCmd _ANSI_ARGS_((ClientData dummy,
  120.                 Tcl_Interp *interp, int objc,
  121.                 Tcl_Obj *CONST objv[]));
  122. static int        InfoLocalsCmd _ANSI_ARGS_((ClientData dummy,
  123.                 Tcl_Interp *interp, int objc,
  124.                 Tcl_Obj *CONST objv[]));
  125. static int        InfoNameOfExecutableCmd _ANSI_ARGS_((
  126.                 ClientData dummy, Tcl_Interp *interp, int objc,
  127.                 Tcl_Obj *CONST objv[]));
  128. static int        InfoPatchLevelCmd _ANSI_ARGS_((ClientData dummy,
  129.                 Tcl_Interp *interp, int objc,
  130.                 Tcl_Obj *CONST objv[]));
  131. static int        InfoProcsCmd _ANSI_ARGS_((ClientData dummy,
  132.                 Tcl_Interp *interp, int objc,
  133.                 Tcl_Obj *CONST objv[]));
  134. static int        InfoScriptCmd _ANSI_ARGS_((ClientData dummy,
  135.                 Tcl_Interp *interp, int objc,
  136.                 Tcl_Obj *CONST objv[]));
  137. static int        InfoSharedlibCmd _ANSI_ARGS_((ClientData dummy,
  138.                 Tcl_Interp *interp, int objc,
  139.                 Tcl_Obj *CONST objv[]));
  140. static int        InfoTclVersionCmd _ANSI_ARGS_((ClientData dummy,
  141.                 Tcl_Interp *interp, int objc,
  142.                 Tcl_Obj *CONST objv[]));
  143. static int        InfoVarsCmd _ANSI_ARGS_((ClientData dummy,
  144.                 Tcl_Interp *interp, int objc,
  145.                 Tcl_Obj *CONST objv[]));
  146. static SortElement *    MergeSort _ANSI_ARGS_((SortElement *headPt,
  147.                 SortInfo *infoPtr));
  148. static SortElement *    MergeLists _ANSI_ARGS_((SortElement *leftPtr,
  149.                 SortElement *rightPtr, SortInfo *infoPtr));
  150. static int        SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
  151.                 Tcl_Obj *second, SortInfo *infoPtr));
  152.  
  153. /*
  154.  *----------------------------------------------------------------------
  155.  *
  156.  * Tcl_IfCmd --
  157.  *
  158.  *    This procedure is invoked to process the "if" Tcl command.
  159.  *    See the user documentation for details on what it does.
  160.  *
  161.  *    With the bytecode compiler, this procedure is only called when
  162.  *    a command name is computed at runtime, and is "if" or the name
  163.  *    to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}"
  164.  *
  165.  * Results:
  166.  *    A standard Tcl result.
  167.  *
  168.  * Side effects:
  169.  *    See the user documentation.
  170.  *
  171.  *----------------------------------------------------------------------
  172.  */
  173.  
  174.     /* ARGSUSED */
  175. int
  176. Tcl_IfCmd(dummy, interp, argc, argv)
  177.     ClientData dummy;            /* Not used. */
  178.     Tcl_Interp *interp;            /* Current interpreter. */
  179.     int argc;                /* Number of arguments. */
  180.     char **argv;            /* Argument strings. */
  181. {
  182.     int i, result, value;
  183.  
  184.     i = 1;
  185.     while (1) {
  186.     /*
  187.      * At this point in the loop, argv and argc refer to an expression
  188.      * to test, either for the main expression or an expression
  189.      * following an "elseif".  The arguments after the expression must
  190.      * be "then" (optional) and a script to execute if the expression is
  191.      * true.
  192.      */
  193.  
  194.     if (i >= argc) {
  195.         Tcl_AppendResult(interp, "wrong # args: no expression after \"",
  196.             argv[i-1], "\" argument", (char *) NULL);
  197.         return TCL_ERROR;
  198.     }
  199.     result = Tcl_ExprBoolean(interp, argv[i], &value);
  200.     if (result != TCL_OK) {
  201.         return result;
  202.     }
  203.     i++;
  204.     if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
  205.         i++;
  206.     }
  207.     if (i >= argc) {
  208.         Tcl_AppendResult(interp, "wrong # args: no script following \"",
  209.             argv[i-1], "\" argument", (char *) NULL);
  210.         return TCL_ERROR;
  211.     }
  212.     if (value) {
  213.         return Tcl_Eval(interp, argv[i]);
  214.     }
  215.     
  216.     /*
  217.      * The expression evaluated to false.  Skip the command, then
  218.      * see if there is an "else" or "elseif" clause.
  219.      */
  220.  
  221.     i++;
  222.     if (i >= argc) {
  223.         return TCL_OK;
  224.     }
  225.     if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
  226.         i++;
  227.         continue;
  228.     }
  229.     break;
  230.     }
  231.  
  232.     /*
  233.      * Couldn't find a "then" or "elseif" clause to execute.  Check now
  234.      * for an "else" clause.  We know that there's at least one more
  235.      * argument when we get here.
  236.      */
  237.  
  238.     if (strcmp(argv[i], "else") == 0) {
  239.     i++;
  240.     if (i >= argc) {
  241.         Tcl_AppendResult(interp,
  242.             "wrong # args: no script following \"else\" argument",
  243.             (char *) NULL);
  244.         return TCL_ERROR;
  245.     }
  246.     }
  247.     return Tcl_Eval(interp, argv[i]);
  248. }
  249.  
  250. /*
  251.  *----------------------------------------------------------------------
  252.  *
  253.  * Tcl_IncrCmd --
  254.  *
  255.  *    This procedure is invoked to process the "incr" Tcl command.
  256.  *    See the user documentation for details on what it does.
  257.  *
  258.  *    With the bytecode compiler, this procedure is only called when
  259.  *    a command name is computed at runtime, and is "incr" or the name
  260.  *    to which "incr" was renamed: e.g., "set z incr; $z i -1"
  261.  *
  262.  * Results:
  263.  *    A standard Tcl result.
  264.  *
  265.  * Side effects:
  266.  *    See the user documentation.
  267.  *
  268.  *----------------------------------------------------------------------
  269.  */
  270.  
  271.     /* ARGSUSED */
  272. int
  273. Tcl_IncrCmd(dummy, interp, argc, argv)
  274.     ClientData dummy;            /* Not used. */
  275.     Tcl_Interp *interp;            /* Current interpreter. */
  276.     int argc;                /* Number of arguments. */
  277.     char **argv;            /* Argument strings. */
  278. {
  279.     int value;
  280.     char *oldString, *result;
  281.     char newString[30];
  282.  
  283.     if ((argc != 2) && (argc != 3)) {
  284.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  285.         " varName ?increment?\"", (char *) NULL);
  286.     return TCL_ERROR;
  287.     }
  288.  
  289.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  290.     if (oldString == NULL) {
  291.     return TCL_ERROR;
  292.     }
  293.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  294.     Tcl_AddErrorInfo(interp,
  295.         "\n    (reading value of variable to increment)");
  296.     return TCL_ERROR;
  297.     }
  298.     if (argc == 2) {
  299.     value += 1;
  300.     } else {
  301.     int increment;
  302.  
  303.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  304.         Tcl_AddErrorInfo(interp,
  305.             "\n    (reading increment)");
  306.         return TCL_ERROR;
  307.     }
  308.     value += increment;
  309.     }
  310.     TclFormatInt(newString, value);
  311.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  312.     if (result == NULL) {
  313.     return TCL_ERROR;
  314.     }
  315.  
  316.     /*
  317.      * Copy the result since the variable's value might change.
  318.      */
  319.     
  320.     Tcl_SetResult(interp, result, TCL_VOLATILE);
  321.     return TCL_OK; 
  322. }
  323.  
  324. /*
  325.  *----------------------------------------------------------------------
  326.  *
  327.  * Tcl_InfoObjCmd --
  328.  *
  329.  *    This procedure is invoked to process the "info" Tcl command.
  330.  *    See the user documentation for details on what it does.
  331.  *
  332.  * Results:
  333.  *    A standard Tcl result.
  334.  *
  335.  * Side effects:
  336.  *    See the user documentation.
  337.  *
  338.  *----------------------------------------------------------------------
  339.  */
  340.  
  341.     /* ARGSUSED */
  342. int
  343. Tcl_InfoObjCmd(clientData, interp, objc, objv)
  344.     ClientData clientData;    /* Arbitrary value passed to the command. */
  345.     Tcl_Interp *interp;        /* Current interpreter. */
  346.     int objc;            /* Number of arguments. */
  347.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  348. {
  349.     static char *subCmds[] = {
  350.             "args", "body", "cmdcount", "commands",
  351.          "complete", "default", "exists", "globals",
  352.          "hostname", "level", "library", "loaded",
  353.          "locals", "nameofexecutable", "patchlevel", "procs",
  354.          "script", "sharedlibextension", "tclversion", "vars",
  355.          (char *) NULL};
  356.     enum ISubCmdIdx {
  357.         IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
  358.         ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
  359.         IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
  360.         ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
  361.         IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
  362.     } index;
  363.     int result;
  364.  
  365.     if (objc < 2) {
  366.         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
  367.         return TCL_ERROR;
  368.     }
  369.     
  370.     result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
  371.         (int *) &index);
  372.     if (result != TCL_OK) {
  373.     return result;
  374.     }
  375.  
  376.     switch (index) {
  377.         case IArgsIdx:
  378.         result = InfoArgsCmd(clientData, interp, objc, objv);
  379.             break;
  380.     case IBodyIdx:
  381.         result = InfoBodyCmd(clientData, interp, objc, objv);
  382.         break;
  383.     case ICmdCountIdx:
  384.         result = InfoCmdCountCmd(clientData, interp, objc, objv);
  385.         break;
  386.         case ICommandsIdx:
  387.         result = InfoCommandsCmd(clientData, interp, objc, objv);
  388.         break;
  389.         case ICompleteIdx:
  390.         result = InfoCompleteCmd(clientData, interp, objc, objv);
  391.         break;
  392.     case IDefaultIdx:
  393.         result = InfoDefaultCmd(clientData, interp, objc, objv);
  394.         break;
  395.     case IExistsIdx:
  396.         result = InfoExistsCmd(clientData, interp, objc, objv);
  397.         break;
  398.         case IGlobalsIdx:
  399.         result = InfoGlobalsCmd(clientData, interp, objc, objv);
  400.         break;
  401.         case IHostnameIdx:
  402.         result = InfoHostnameCmd(clientData, interp, objc, objv);
  403.         break;
  404.     case ILevelIdx:
  405.         result = InfoLevelCmd(clientData, interp, objc, objv);
  406.         break;
  407.     case ILibraryIdx:
  408.         result = InfoLibraryCmd(clientData, interp, objc, objv);
  409.         break;
  410.         case ILoadedIdx:
  411.         result = InfoLoadedCmd(clientData, interp, objc, objv);
  412.         break;
  413.         case ILocalsIdx:
  414.         result = InfoLocalsCmd(clientData, interp, objc, objv);
  415.         break;
  416.     case INameOfExecutableIdx:
  417.         result = InfoNameOfExecutableCmd(clientData, interp, objc, objv);
  418.         break;
  419.     case IPatchLevelIdx:
  420.         result = InfoPatchLevelCmd(clientData, interp, objc, objv);
  421.         break;
  422.         case IProcsIdx:
  423.         result = InfoProcsCmd(clientData, interp, objc, objv);
  424.         break;
  425.         case IScriptIdx:
  426.         result = InfoScriptCmd(clientData, interp, objc, objv);
  427.         break;
  428.     case ISharedLibExtensionIdx:
  429.         result = InfoSharedlibCmd(clientData, interp, objc, objv);
  430.         break;
  431.     case ITclVersionIdx:
  432.         result = InfoTclVersionCmd(clientData, interp, objc, objv);
  433.         break;
  434.     case IVarsIdx:
  435.         result = InfoVarsCmd(clientData, interp, objc, objv);
  436.         break;
  437.     }
  438.     return result;
  439. }
  440.  
  441. /*
  442.  *----------------------------------------------------------------------
  443.  *
  444.  * InfoArgsCmd --
  445.  *
  446.  *      Called to implement the "info args" command that returns the
  447.  *      argument list for a procedure. Handles the following syntax:
  448.  *
  449.  *          info args procName
  450.  *
  451.  * Results:
  452.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  453.  *
  454.  * Side effects:
  455.  *      Returns a result in the interpreter's result object. If there is
  456.  *    an error, the result is an error message.
  457.  *
  458.  *----------------------------------------------------------------------
  459.  */
  460.  
  461. static int
  462. InfoArgsCmd(dummy, interp, objc, objv)
  463.     ClientData dummy;        /* Not used. */
  464.     Tcl_Interp *interp;        /* Current interpreter. */
  465.     int objc;            /* Number of arguments. */
  466.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  467. {
  468.     register Interp *iPtr = (Interp *) interp;
  469.     char *name;
  470.     Proc *procPtr;
  471.     CompiledLocal *localPtr;
  472.     Tcl_Obj *listObjPtr;
  473.  
  474.     if (objc != 3) {
  475.         Tcl_WrongNumArgs(interp, 2, objv, "procname");
  476.         return TCL_ERROR;
  477.     }
  478.  
  479.     name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  480.     procPtr = TclFindProc(iPtr, name);
  481.     if (procPtr == NULL) {
  482.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  483.                 "\"", name, "\" isn't a procedure", (char *) NULL);
  484.         return TCL_ERROR;
  485.     }
  486.  
  487.     /*
  488.      * Build a return list containing the arguments.
  489.      */
  490.     
  491.     listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  492.     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
  493.             localPtr = localPtr->nextPtr) {
  494.         if (localPtr->isArg) {
  495.             Tcl_ListObjAppendElement(interp, listObjPtr,
  496.             Tcl_NewStringObj(localPtr->name, -1));
  497.         }
  498.     }
  499.     Tcl_SetObjResult(interp, listObjPtr);
  500.     return TCL_OK;
  501. }
  502.  
  503. /*
  504.  *----------------------------------------------------------------------
  505.  *
  506.  * InfoBodyCmd --
  507.  *
  508.  *      Called to implement the "info body" command that returns the body
  509.  *      for a procedure. Handles the following syntax:
  510.  *
  511.  *          info body procName
  512.  *
  513.  * Results:
  514.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  515.  *
  516.  * Side effects:
  517.  *      Returns a result in the interpreter's result object. If there is
  518.  *    an error, the result is an error message.
  519.  *
  520.  *----------------------------------------------------------------------
  521.  */
  522.  
  523. static int
  524. InfoBodyCmd(dummy, interp, objc, objv)
  525.     ClientData dummy;        /* Not used. */
  526.     Tcl_Interp *interp;        /* Current interpreter. */
  527.     int objc;            /* Number of arguments. */
  528.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  529. {
  530.     register Interp *iPtr = (Interp *) interp;
  531.     char *name;
  532.     Proc *procPtr;
  533.  
  534.     if (objc != 3) {
  535.         Tcl_WrongNumArgs(interp, 2, objv, "procname");
  536.         return TCL_ERROR;
  537.     }
  538.  
  539.     name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  540.     procPtr = TclFindProc(iPtr, name);
  541.     if (procPtr == NULL) {
  542.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  543.         "\"", name, "\" isn't a procedure", (char *) NULL);
  544.         return TCL_ERROR;
  545.     }
  546.     Tcl_SetObjResult(interp, procPtr->bodyPtr);
  547.     return TCL_OK;
  548. }
  549.  
  550. /*
  551.  *----------------------------------------------------------------------
  552.  *
  553.  * InfoCmdCountCmd --
  554.  *
  555.  *      Called to implement the "info cmdcount" command that returns the
  556.  *      number of commands that have been executed. Handles the following
  557.  *      syntax:
  558.  *
  559.  *          info cmdcount
  560.  *
  561.  * Results:
  562.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  563.  *
  564.  * Side effects:
  565.  *      Returns a result in the interpreter's result object. If there is
  566.  *    an error, the result is an error message.
  567.  *
  568.  *----------------------------------------------------------------------
  569.  */
  570.  
  571. static int
  572. InfoCmdCountCmd(dummy, interp, objc, objv)
  573.     ClientData dummy;        /* Not used. */
  574.     Tcl_Interp *interp;        /* Current interpreter. */
  575.     int objc;            /* Number of arguments. */
  576.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  577. {
  578.     Interp *iPtr = (Interp *) interp;
  579.     
  580.     if (objc != 2) {
  581.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  582.         return TCL_ERROR;
  583.     }
  584.  
  585.     Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->cmdCount);
  586.     return TCL_OK;
  587. }
  588.  
  589. /*
  590.  *----------------------------------------------------------------------
  591.  *
  592.  * InfoCommandsCmd --
  593.  *
  594.  *    Called to implement the "info commands" command that returns the
  595.  *    list of commands in the interpreter that match an optional pattern.
  596.  *    The pattern, if any, consists of an optional sequence of namespace
  597.  *    names separated by "::" qualifiers, which is followed by a
  598.  *    glob-style pattern that restricts which commands are returned.
  599.  *    Handles the following syntax:
  600.  *
  601.  *          info commands ?pattern?
  602.  *
  603.  * Results:
  604.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  605.  *
  606.  * Side effects:
  607.  *      Returns a result in the interpreter's result object. If there is
  608.  *    an error, the result is an error message.
  609.  *
  610.  *----------------------------------------------------------------------
  611.  */
  612.  
  613. static int
  614. InfoCommandsCmd(dummy, interp, objc, objv)
  615.     ClientData dummy;        /* Not used. */
  616.     Tcl_Interp *interp;        /* Current interpreter. */
  617.     int objc;            /* Number of arguments. */
  618.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  619. {
  620.     char *cmdName, *pattern, *simplePattern;
  621.     register Tcl_HashEntry *entryPtr;
  622.     Tcl_HashSearch search;
  623.     Namespace *nsPtr;
  624.     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
  625.     Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
  626.     Tcl_Obj *listPtr, *elemObjPtr;
  627.     int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
  628.     Tcl_Command cmd;
  629.     int result;
  630.  
  631.     /*
  632.      * Get the pattern and find the "effective namespace" in which to
  633.      * list commands.
  634.      */
  635.  
  636.     if (objc == 2) {
  637.         simplePattern = NULL;
  638.     nsPtr = currNsPtr;
  639.     specificNsInPattern = 0;
  640.     } else if (objc == 3) {
  641.     /*
  642.      * From the pattern, get the effective namespace and the simple
  643.      * pattern (no namespace qualifiers or ::'s) at the end. If an
  644.      * error was found while parsing the pattern, return it. Otherwise,
  645.      * if the namespace wasn't found, just leave nsPtr NULL: we will
  646.      * return an empty list since no commands there can be found.
  647.      */
  648.  
  649.     Namespace *dummy1NsPtr, *dummy2NsPtr;
  650.     
  651.         pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  652.     result = TclGetNamespaceForQualName(interp, pattern,
  653.         (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
  654.         &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
  655.     if (result != TCL_OK) {
  656.         return TCL_ERROR;
  657.     }
  658.     if (nsPtr != NULL) {    /* we successfully found the pattern's ns */
  659.         specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
  660.     }
  661.     } else {
  662.         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
  663.         return TCL_ERROR;
  664.     }
  665.  
  666.     /*
  667.      * Scan through the effective namespace's command table and create a
  668.      * list with all commands that match the pattern. If a specific
  669.      * namespace was requested in the pattern, qualify the command names
  670.      * with the namespace name.
  671.      */
  672.  
  673.     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  674.  
  675.     if (nsPtr != NULL) {
  676.     entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
  677.     while (entryPtr != NULL) {
  678.         cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
  679.         if ((simplePattern == NULL)
  680.                 || Tcl_StringMatch(cmdName, simplePattern)) {
  681.         if (specificNsInPattern) {
  682.             cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
  683.             elemObjPtr = Tcl_NewObj();
  684.             Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
  685.         } else {
  686.             elemObjPtr = Tcl_NewStringObj(cmdName, -1);
  687.         }
  688.         Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
  689.         }
  690.         entryPtr = Tcl_NextHashEntry(&search);
  691.     }
  692.  
  693.     /*
  694.      * If the effective namespace isn't the global :: namespace, and a
  695.      * specific namespace wasn't requested in the pattern, then add in
  696.      * all global :: commands that match the simple pattern. Of course,
  697.      * we add in only those commands that aren't hidden by a command in
  698.      * the effective namespace.
  699.      */
  700.     
  701.     if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
  702.         entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
  703.         while (entryPtr != NULL) {
  704.         cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
  705.         if ((simplePattern == NULL)
  706.                     || Tcl_StringMatch(cmdName, simplePattern)) {
  707.             if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
  708.             Tcl_ListObjAppendElement(interp, listPtr,
  709.                 Tcl_NewStringObj(cmdName, -1));
  710.             }
  711.         }
  712.         entryPtr = Tcl_NextHashEntry(&search);
  713.         }
  714.     }
  715.     }
  716.     
  717.     Tcl_SetObjResult(interp, listPtr);
  718.     return TCL_OK;
  719. }
  720.  
  721. /*
  722.  *----------------------------------------------------------------------
  723.  *
  724.  * InfoCompleteCmd --
  725.  *
  726.  *      Called to implement the "info complete" command that determines
  727.  *      whether a string is a complete Tcl command. Handles the following
  728.  *      syntax:
  729.  *
  730.  *          info complete command
  731.  *
  732.  * Results:
  733.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  734.  *
  735.  * Side effects:
  736.  *      Returns a result in the interpreter's result object. If there is
  737.  *    an error, the result is an error message.
  738.  *
  739.  *----------------------------------------------------------------------
  740.  */
  741.  
  742. static int
  743. InfoCompleteCmd(dummy, interp, objc, objv)
  744.     ClientData dummy;        /* Not used. */
  745.     Tcl_Interp *interp;        /* Current interpreter. */
  746.     int objc;            /* Number of arguments. */
  747.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  748. {
  749.     char *command;
  750.  
  751.     if (objc != 3) {
  752.         Tcl_WrongNumArgs(interp, 2, objv, "command");
  753.         return TCL_ERROR;
  754.     }
  755.  
  756.     command = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  757.     if (Tcl_CommandComplete(command)) {
  758.     Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
  759.     } else {
  760.     Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
  761.     }
  762.     return TCL_OK;
  763. }
  764.  
  765. /*
  766.  *----------------------------------------------------------------------
  767.  *
  768.  * InfoDefaultCmd --
  769.  *
  770.  *      Called to implement the "info default" command that returns the
  771.  *      default value for a procedure argument. Handles the following
  772.  *      syntax:
  773.  *
  774.  *          info default procName arg varName
  775.  *
  776.  * Results:
  777.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  778.  *
  779.  * Side effects:
  780.  *      Returns a result in the interpreter's result object. If there is
  781.  *    an error, the result is an error message.
  782.  *
  783.  *----------------------------------------------------------------------
  784.  */
  785.  
  786. static int
  787. InfoDefaultCmd(dummy, interp, objc, objv)
  788.     ClientData dummy;        /* Not used. */
  789.     Tcl_Interp *interp;        /* Current interpreter. */
  790.     int objc;            /* Number of arguments. */
  791.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  792. {
  793.     Interp *iPtr = (Interp *) interp;
  794.     char *procName, *argName, *varName;
  795.     Proc *procPtr;
  796.     CompiledLocal *localPtr;
  797.     Tcl_Obj *valueObjPtr;
  798.  
  799.     if (objc != 5) {
  800.         Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
  801.         return TCL_ERROR;
  802.     }
  803.  
  804.     procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  805.     argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
  806.  
  807.     procPtr = TclFindProc(iPtr, procName);
  808.     if (procPtr == NULL) {
  809.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  810.         "\"", procName, "\" isn't a procedure", (char *) NULL);
  811.         return TCL_ERROR;
  812.     }
  813.  
  814.     for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
  815.             localPtr = localPtr->nextPtr) {
  816.         if ((localPtr->isArg) && (strcmp(argName, localPtr->name) == 0)) {
  817.             if (localPtr->defValuePtr != NULL) {
  818.         valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
  819.                         localPtr->defValuePtr, 0);
  820.                 if (valueObjPtr == NULL) {
  821.                     defStoreError:
  822.             varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
  823.             Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  824.                         "couldn't store default value in variable \"",
  825.                 varName, "\"", (char *) NULL);
  826.                     return TCL_ERROR;
  827.                 }
  828.         Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
  829.             } else {
  830.                 Tcl_Obj *nullObjPtr = Tcl_NewObj();
  831.                 valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
  832.                     nullObjPtr, 0);
  833.                 if (valueObjPtr == NULL) {
  834.                     Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
  835.                     goto defStoreError;
  836.                 }
  837.         Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
  838.             }
  839.             return TCL_OK;
  840.         }
  841.     }
  842.  
  843.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  844.         "procedure \"", procName, "\" doesn't have an argument \"",
  845.         argName, "\"", (char *) NULL);
  846.     return TCL_ERROR;
  847. }
  848.  
  849. /*
  850.  *----------------------------------------------------------------------
  851.  *
  852.  * InfoExistsCmd --
  853.  *
  854.  *      Called to implement the "info exists" command that determines
  855.  *      whether a variable exists. Handles the following syntax:
  856.  *
  857.  *          info exists varName
  858.  *
  859.  * Results:
  860.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  861.  *
  862.  * Side effects:
  863.  *      Returns a result in the interpreter's result object. If there is
  864.  *    an error, the result is an error message.
  865.  *
  866.  *----------------------------------------------------------------------
  867.  */
  868.  
  869. static int
  870. InfoExistsCmd(dummy, interp, objc, objv)
  871.     ClientData dummy;        /* Not used. */
  872.     Tcl_Interp *interp;        /* Current interpreter. */
  873.     int objc;            /* Number of arguments. */
  874.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  875. {
  876.     char *varName;
  877.     Var *varPtr, *arrayPtr;
  878.  
  879.     if (objc != 3) {
  880.         Tcl_WrongNumArgs(interp, 2, objv, "varName");
  881.         return TCL_ERROR;
  882.     }
  883.  
  884.     varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  885.     varPtr = TclLookupVar(interp, varName, (char *) NULL,
  886.             TCL_PARSE_PART1, "access",
  887.             /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
  888.     if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
  889.         Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
  890.     } else {
  891.         Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
  892.     }
  893.     return TCL_OK;
  894. }
  895.  
  896. /*
  897.  *----------------------------------------------------------------------
  898.  *
  899.  * InfoGlobalsCmd --
  900.  *
  901.  *      Called to implement the "info globals" command that returns the list
  902.  *      of global variables matching an optional pattern. Handles the
  903.  *      following syntax:
  904.  *
  905.  *          info globals ?pattern?
  906.  *
  907.  * Results:
  908.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  909.  *
  910.  * Side effects:
  911.  *      Returns a result in the interpreter's result object. If there is
  912.  *    an error, the result is an error message.
  913.  *
  914.  *----------------------------------------------------------------------
  915.  */
  916.  
  917. static int
  918. InfoGlobalsCmd(dummy, interp, objc, objv)
  919.     ClientData dummy;        /* Not used. */
  920.     Tcl_Interp *interp;        /* Current interpreter. */
  921.     int objc;            /* Number of arguments. */
  922.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  923. {
  924.     char *varName, *pattern;
  925.     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
  926.     register Tcl_HashEntry *entryPtr;
  927.     Tcl_HashSearch search;
  928.     Var *varPtr;
  929.     Tcl_Obj *listPtr;
  930.  
  931.     if (objc == 2) {
  932.         pattern = NULL;
  933.     } else if (objc == 3) {
  934.         pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  935.     } else {
  936.         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
  937.         return TCL_ERROR;
  938.     }
  939.  
  940.     /*
  941.      * Scan through the global :: namespace's variable table and create a
  942.      * list of all global variables that match the pattern.
  943.      */
  944.     
  945.     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  946.     for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
  947.             entryPtr != NULL;
  948.             entryPtr = Tcl_NextHashEntry(&search)) {
  949.         varPtr = (Var *) Tcl_GetHashValue(entryPtr);
  950.         if (TclIsVarUndefined(varPtr)) {
  951.             continue;
  952.         }
  953.         varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
  954.         if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
  955.             Tcl_ListObjAppendElement(interp, listPtr,
  956.             Tcl_NewStringObj(varName, -1));
  957.         }
  958.     }
  959.     Tcl_SetObjResult(interp, listPtr);
  960.     return TCL_OK;
  961. }
  962.  
  963. /*
  964.  *----------------------------------------------------------------------
  965.  *
  966.  * InfoHostnameCmd --
  967.  *
  968.  *      Called to implement the "info hostname" command that returns the
  969.  *      host name. Handles the following syntax:
  970.  *
  971.  *          info hostname
  972.  *
  973.  * Results:
  974.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  975.  *
  976.  * Side effects:
  977.  *      Returns a result in the interpreter's result object. If there is
  978.  *    an error, the result is an error message.
  979.  *
  980.  *----------------------------------------------------------------------
  981.  */
  982.  
  983. static int
  984. InfoHostnameCmd(dummy, interp, objc, objv)
  985.     ClientData dummy;        /* Not used. */
  986.     Tcl_Interp *interp;        /* Current interpreter. */
  987.     int objc;            /* Number of arguments. */
  988.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  989. {
  990.     if (objc != 2) {
  991.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  992.         return TCL_ERROR;
  993.     }
  994.  
  995.     Tcl_SetStringObj(Tcl_GetObjResult(interp), Tcl_GetHostName(), -1);
  996.     return TCL_OK;
  997. }
  998.  
  999. /*
  1000.  *----------------------------------------------------------------------
  1001.  *
  1002.  * InfoLevelCmd --
  1003.  *
  1004.  *      Called to implement the "info level" command that returns
  1005.  *      information about the call stack. Handles the following syntax:
  1006.  *
  1007.  *          info level ?number?
  1008.  *
  1009.  * Results:
  1010.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1011.  *
  1012.  * Side effects:
  1013.  *      Returns a result in the interpreter's result object. If there is
  1014.  *    an error, the result is an error message.
  1015.  *
  1016.  *----------------------------------------------------------------------
  1017.  */
  1018.  
  1019. static int
  1020. InfoLevelCmd(dummy, interp, objc, objv)
  1021.     ClientData dummy;        /* Not used. */
  1022.     Tcl_Interp *interp;        /* Current interpreter. */
  1023.     int objc;            /* Number of arguments. */
  1024.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1025. {
  1026.     Interp *iPtr = (Interp *) interp;
  1027.     int level;
  1028.     CallFrame *framePtr;
  1029.     Tcl_Obj *listPtr;
  1030.  
  1031.     if (objc == 2) {        /* just "info level" */
  1032.         if (iPtr->varFramePtr == NULL) {
  1033.             Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
  1034.         } else {
  1035.             Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
  1036.         }
  1037.         return TCL_OK;
  1038.     } else if (objc == 3) {
  1039.         if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
  1040.             return TCL_ERROR;
  1041.         }
  1042.         if (level <= 0) {
  1043.             if (iPtr->varFramePtr == NULL) {
  1044.                 levelError:
  1045.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1046.             "bad level \"",
  1047.             Tcl_GetStringFromObj(objv[2], (int *) NULL),
  1048.             "\"", (char *) NULL);
  1049.                 return TCL_ERROR;
  1050.             }
  1051.             level += iPtr->varFramePtr->level;
  1052.         }
  1053.         for (framePtr = iPtr->varFramePtr;  framePtr != NULL;
  1054.                 framePtr = framePtr->callerVarPtr) {
  1055.             if (framePtr->level == level) {
  1056.                 break;
  1057.             }
  1058.         }
  1059.         if (framePtr == NULL) {
  1060.             goto levelError;
  1061.         }
  1062.  
  1063.         listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
  1064.         Tcl_SetObjResult(interp, listPtr);
  1065.         return TCL_OK;
  1066.     }
  1067.  
  1068.     Tcl_WrongNumArgs(interp, 2, objv, "?number?");
  1069.     return TCL_ERROR;
  1070. }
  1071.  
  1072. /*
  1073.  *----------------------------------------------------------------------
  1074.  *
  1075.  * InfoLibraryCmd --
  1076.  *
  1077.  *      Called to implement the "info library" command that returns the
  1078.  *      library directory for the Tcl installation. Handles the following
  1079.  *      syntax:
  1080.  *
  1081.  *          info library
  1082.  *
  1083.  * Results:
  1084.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1085.  *
  1086.  * Side effects:
  1087.  *      Returns a result in the interpreter's result object. If there is
  1088.  *    an error, the result is an error message.
  1089.  *
  1090.  *----------------------------------------------------------------------
  1091.  */
  1092.  
  1093. static int
  1094. InfoLibraryCmd(dummy, interp, objc, objv)
  1095.     ClientData dummy;        /* Not used. */
  1096.     Tcl_Interp *interp;        /* Current interpreter. */
  1097.     int objc;            /* Number of arguments. */
  1098.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1099. {
  1100.     char *libDirName;
  1101.  
  1102.     if (objc != 2) {
  1103.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  1104.         return TCL_ERROR;
  1105.     }
  1106.  
  1107.     libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
  1108.     if (libDirName != NULL) {
  1109.         Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
  1110.         return TCL_OK;
  1111.     }
  1112.     Tcl_SetStringObj(Tcl_GetObjResult(interp), 
  1113.             "no library has been specified for Tcl", -1);
  1114.     return TCL_ERROR;
  1115. }
  1116.  
  1117. /*
  1118.  *----------------------------------------------------------------------
  1119.  *
  1120.  * InfoLoadedCmd --
  1121.  *
  1122.  *      Called to implement the "info loaded" command that returns the
  1123.  *      packages that have been loaded into an interpreter. Handles the
  1124.  *      following syntax:
  1125.  *
  1126.  *          info loaded ?interp?
  1127.  *
  1128.  * Results:
  1129.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1130.  *
  1131.  * Side effects:
  1132.  *      Returns a result in the interpreter's result object. If there is
  1133.  *    an error, the result is an error message.
  1134.  *
  1135.  *----------------------------------------------------------------------
  1136.  */
  1137.  
  1138. static int
  1139. InfoLoadedCmd(dummy, interp, objc, objv)
  1140.     ClientData dummy;        /* Not used. */
  1141.     Tcl_Interp *interp;        /* Current interpreter. */
  1142.     int objc;            /* Number of arguments. */
  1143.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1144. {
  1145.     char *interpName;
  1146.     int result;
  1147.  
  1148.     if ((objc != 2) && (objc != 3)) {
  1149.         Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
  1150.         return TCL_ERROR;
  1151.     }
  1152.  
  1153.     if (objc == 2) {        /* get loaded pkgs in all interpreters */
  1154.     interpName = NULL;
  1155.     } else {            /* get pkgs just in specified interp */
  1156.     interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  1157.     }
  1158.     result = TclGetLoadedPackages(interp, interpName);
  1159.     return result;
  1160. }
  1161.  
  1162. /*
  1163.  *----------------------------------------------------------------------
  1164.  *
  1165.  * InfoLocalsCmd --
  1166.  *
  1167.  *      Called to implement the "info locals" command to return a list of
  1168.  *      local variables that match an optional pattern. Handles the
  1169.  *      following syntax:
  1170.  *
  1171.  *          info locals ?pattern?
  1172.  *
  1173.  * Results:
  1174.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1175.  *
  1176.  * Side effects:
  1177.  *      Returns a result in the interpreter's result object. If there is
  1178.  *    an error, the result is an error message.
  1179.  *
  1180.  *----------------------------------------------------------------------
  1181.  */
  1182.  
  1183. static int
  1184. InfoLocalsCmd(dummy, interp, objc, objv)
  1185.     ClientData dummy;        /* Not used. */
  1186.     Tcl_Interp *interp;        /* Current interpreter. */
  1187.     int objc;            /* Number of arguments. */
  1188.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1189. {
  1190.     Interp *iPtr = (Interp *) interp;
  1191.     Var *varPtr;
  1192.     char *varName, *pattern;
  1193.     int i, localVarCt;
  1194.     Tcl_HashTable *localVarTablePtr;
  1195.     register Tcl_HashEntry *entryPtr;
  1196.     Tcl_HashSearch search;
  1197.     Tcl_Obj *listPtr;
  1198.  
  1199.     if (objc == 2) {
  1200.         pattern = NULL;
  1201.     } else if (objc == 3) {
  1202.         pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  1203.     } else {
  1204.         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
  1205.         return TCL_ERROR;
  1206.     }
  1207.     
  1208.     if (iPtr->varFramePtr == NULL) {
  1209.         return TCL_OK;
  1210.     }
  1211.     localVarTablePtr = iPtr->varFramePtr->varTablePtr;
  1212.  
  1213.     /*
  1214.      * Return a list containing names of first the compiled locals (i.e. the
  1215.      * ones stored in the call frame), then the variables in the local hash
  1216.      * table (if one exists).
  1217.      */
  1218.     
  1219.     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  1220.     
  1221.     localVarCt = iPtr->varFramePtr->numCompiledLocals;
  1222.     for (i = 0, varPtr = iPtr->varFramePtr->compiledLocals;
  1223.             i < localVarCt;
  1224.         i++, varPtr++) {
  1225.     if (!TclIsVarUndefined(varPtr)) {
  1226.         varName = varPtr->name;
  1227.         if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
  1228.         Tcl_ListObjAppendElement(interp, listPtr,
  1229.                 Tcl_NewStringObj(varName, -1));
  1230.         }
  1231.         }
  1232.     }
  1233.     
  1234.     if (localVarTablePtr != NULL) {
  1235.     for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search);
  1236.             entryPtr != NULL;
  1237.                 entryPtr = Tcl_NextHashEntry(&search)) {
  1238.         varPtr = (Var *) Tcl_GetHashValue(entryPtr);
  1239.         if (!TclIsVarUndefined(varPtr) && !TclIsVarLink(varPtr)) {
  1240.         varName = Tcl_GetHashKey(localVarTablePtr, entryPtr);
  1241.         if ((pattern == NULL)
  1242.                 || Tcl_StringMatch(varName, pattern)) {
  1243.             Tcl_ListObjAppendElement(interp, listPtr,
  1244.                 Tcl_NewStringObj(varName, -1));
  1245.         }
  1246.         }
  1247.     }
  1248.     }
  1249.     
  1250.     Tcl_SetObjResult(interp, listPtr);
  1251.     return TCL_OK;
  1252. }
  1253.  
  1254. /*
  1255.  *----------------------------------------------------------------------
  1256.  *
  1257.  * InfoNameOfExecutableCmd --
  1258.  *
  1259.  *      Called to implement the "info nameofexecutable" command that returns
  1260.  *      the name of the binary file running this application. Handles the
  1261.  *      following syntax:
  1262.  *
  1263.  *          info nameofexecutable
  1264.  *
  1265.  * Results:
  1266.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1267.  *
  1268.  * Side effects:
  1269.  *      Returns a result in the interpreter's result object. If there is
  1270.  *    an error, the result is an error message.
  1271.  *
  1272.  *----------------------------------------------------------------------
  1273.  */
  1274.  
  1275. static int
  1276. InfoNameOfExecutableCmd(dummy, interp, objc, objv)
  1277.     ClientData dummy;        /* Not used. */
  1278.     Tcl_Interp *interp;        /* Current interpreter. */
  1279.     int objc;            /* Number of arguments. */
  1280.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1281. {
  1282.     if (objc != 2) {
  1283.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  1284.         return TCL_ERROR;
  1285.     }
  1286.     
  1287.     if (tclExecutableName != NULL) {
  1288.     Tcl_SetStringObj(Tcl_GetObjResult(interp), tclExecutableName, -1);
  1289.     }
  1290.     return TCL_OK;
  1291. }
  1292.  
  1293. /*
  1294.  *----------------------------------------------------------------------
  1295.  *
  1296.  * InfoPatchLevelCmd --
  1297.  *
  1298.  *      Called to implement the "info patchlevel" command that returns the
  1299.  *      default value for an argument to a procedure. Handles the following
  1300.  *      syntax:
  1301.  *
  1302.  *          info patchlevel
  1303.  *
  1304.  * Results:
  1305.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1306.  *
  1307.  * Side effects:
  1308.  *      Returns a result in the interpreter's result object. If there is
  1309.  *    an error, the result is an error message.
  1310.  *
  1311.  *----------------------------------------------------------------------
  1312.  */
  1313.  
  1314. static int
  1315. InfoPatchLevelCmd(dummy, interp, objc, objv)
  1316.     ClientData dummy;        /* Not used. */
  1317.     Tcl_Interp *interp;        /* Current interpreter. */
  1318.     int objc;            /* Number of arguments. */
  1319.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1320. {
  1321.     char *patchlevel;
  1322.  
  1323.     if (objc != 2) {
  1324.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  1325.         return TCL_ERROR;
  1326.     }
  1327.  
  1328.     patchlevel = Tcl_GetVar(interp, "tcl_patchLevel",
  1329.             (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
  1330.     if (patchlevel != NULL) {
  1331.         Tcl_SetStringObj(Tcl_GetObjResult(interp), patchlevel, -1);
  1332.         return TCL_OK;
  1333.     }
  1334.     return TCL_ERROR;
  1335. }
  1336.  
  1337. /*
  1338.  *----------------------------------------------------------------------
  1339.  *
  1340.  * InfoProcsCmd --
  1341.  *
  1342.  *      Called to implement the "info procs" command that returns the
  1343.  *      procedures in the current namespace that match an optional pattern.
  1344.  *      Handles the following syntax:
  1345.  *
  1346.  *          info procs ?pattern?
  1347.  *
  1348.  * Results:
  1349.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1350.  *
  1351.  * Side effects:
  1352.  *      Returns a result in the interpreter's result object. If there is
  1353.  *    an error, the result is an error message.
  1354.  *
  1355.  *----------------------------------------------------------------------
  1356.  */
  1357.  
  1358. static int
  1359. InfoProcsCmd(dummy, interp, objc, objv)
  1360.     ClientData dummy;        /* Not used. */
  1361.     Tcl_Interp *interp;        /* Current interpreter. */
  1362.     int objc;            /* Number of arguments. */
  1363.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1364. {
  1365.     char *cmdName, *pattern;
  1366.     Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
  1367.     register Tcl_HashEntry *entryPtr;
  1368.     Tcl_HashSearch search;
  1369.     Command *cmdPtr;
  1370.     Tcl_Obj *listPtr;
  1371.  
  1372.     if (objc == 2) {
  1373.         pattern = NULL;
  1374.     } else if (objc == 3) {
  1375.         pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  1376.     } else {
  1377.         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
  1378.         return TCL_ERROR;
  1379.     }
  1380.  
  1381.     /*
  1382.      * Scan through the current namespace's command table and return a list
  1383.      * of all procs that match the pattern.
  1384.      */
  1385.     
  1386.     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  1387.     for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
  1388.             entryPtr != NULL;
  1389.             entryPtr = Tcl_NextHashEntry(&search)) {
  1390.         cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
  1391.         cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
  1392.         if (TclIsProc(cmdPtr)) {
  1393.             if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
  1394.                 Tcl_ListObjAppendElement(interp, listPtr,
  1395.                 Tcl_NewStringObj(cmdName, -1));
  1396.             }
  1397.         }
  1398.     }
  1399.     Tcl_SetObjResult(interp, listPtr);
  1400.     return TCL_OK;
  1401. }
  1402.  
  1403. /*
  1404.  *----------------------------------------------------------------------
  1405.  *
  1406.  * InfoScriptCmd --
  1407.  *
  1408.  *      Called to implement the "info script" command that returns the
  1409.  *      script file that is currently being evaluated. Handles the
  1410.  *      following syntax:
  1411.  *
  1412.  *          info script
  1413.  *
  1414.  * Results:
  1415.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1416.  *
  1417.  * Side effects:
  1418.  *      Returns a result in the interpreter's result object. If there is
  1419.  *    an error, the result is an error message.
  1420.  *
  1421.  *----------------------------------------------------------------------
  1422.  */
  1423.  
  1424. static int
  1425. InfoScriptCmd(dummy, interp, objc, objv)
  1426.     ClientData dummy;        /* Not used. */
  1427.     Tcl_Interp *interp;        /* Current interpreter. */
  1428.     int objc;            /* Number of arguments. */
  1429.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1430. {
  1431.     Interp *iPtr = (Interp *) interp;
  1432.     if (objc != 2) {
  1433.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  1434.         return TCL_ERROR;
  1435.     }
  1436.  
  1437.     if (iPtr->scriptFile != NULL) {
  1438.         Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
  1439.     }
  1440.     return TCL_OK;
  1441. }
  1442.  
  1443. /*
  1444.  *----------------------------------------------------------------------
  1445.  *
  1446.  * InfoSharedlibCmd --
  1447.  *
  1448.  *      Called to implement the "info sharedlibextension" command that
  1449.  *      returns the file extension used for shared libraries. Handles the
  1450.  *      following syntax:
  1451.  *
  1452.  *          info sharedlibextension
  1453.  *
  1454.  * Results:
  1455.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1456.  *
  1457.  * Side effects:
  1458.  *      Returns a result in the interpreter's result object. If there is
  1459.  *    an error, the result is an error message.
  1460.  *
  1461.  *----------------------------------------------------------------------
  1462.  */
  1463.  
  1464. static int
  1465. InfoSharedlibCmd(dummy, interp, objc, objv)
  1466.     ClientData dummy;        /* Not used. */
  1467.     Tcl_Interp *interp;        /* Current interpreter. */
  1468.     int objc;            /* Number of arguments. */
  1469.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1470. {
  1471.     if (objc != 2) {
  1472.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  1473.         return TCL_ERROR;
  1474.     }
  1475.     
  1476. #ifdef TCL_SHLIB_EXT
  1477.     Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
  1478. #endif
  1479.     return TCL_OK;
  1480. }
  1481.  
  1482. /*
  1483.  *----------------------------------------------------------------------
  1484.  *
  1485.  * InfoTclVersionCmd --
  1486.  *
  1487.  *      Called to implement the "info tclversion" command that returns the
  1488.  *      version number for this Tcl library. Handles the following syntax:
  1489.  *
  1490.  *          info tclversion
  1491.  *
  1492.  * Results:
  1493.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1494.  *
  1495.  * Side effects:
  1496.  *      Returns a result in the interpreter's result object. If there is
  1497.  *    an error, the result is an error message.
  1498.  *
  1499.  *----------------------------------------------------------------------
  1500.  */
  1501.  
  1502. static int
  1503. InfoTclVersionCmd(dummy, interp, objc, objv)
  1504.     ClientData dummy;        /* Not used. */
  1505.     Tcl_Interp *interp;        /* Current interpreter. */
  1506.     int objc;            /* Number of arguments. */
  1507.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1508. {
  1509.     char *version;
  1510.  
  1511.     if (objc != 2) {
  1512.         Tcl_WrongNumArgs(interp, 2, objv, NULL);
  1513.         return TCL_ERROR;
  1514.     }
  1515.  
  1516.     version = Tcl_GetVar(interp, "tcl_version",
  1517.         (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
  1518.     if (version != NULL) {
  1519.         Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
  1520.         return TCL_OK;
  1521.     }
  1522.     return TCL_ERROR;
  1523. }
  1524.  
  1525. /*
  1526.  *----------------------------------------------------------------------
  1527.  *
  1528.  * InfoVarsCmd --
  1529.  *
  1530.  *    Called to implement the "info vars" command that returns the
  1531.  *    list of variables in the interpreter that match an optional pattern.
  1532.  *    The pattern, if any, consists of an optional sequence of namespace
  1533.  *    names separated by "::" qualifiers, which is followed by a
  1534.  *    glob-style pattern that restricts which variables are returned.
  1535.  *    Handles the following syntax:
  1536.  *
  1537.  *          info vars ?pattern?
  1538.  *
  1539.  * Results:
  1540.  *      Returns TCL_OK is successful and TCL_ERROR is there is an error.
  1541.  *
  1542.  * Side effects:
  1543.  *      Returns a result in the interpreter's result object. If there is
  1544.  *    an error, the result is an error message.
  1545.  *
  1546.  *----------------------------------------------------------------------
  1547.  */
  1548.  
  1549. static int
  1550. InfoVarsCmd(dummy, interp, objc, objv)
  1551.     ClientData dummy;        /* Not used. */
  1552.     Tcl_Interp *interp;        /* Current interpreter. */
  1553.     int objc;            /* Number of arguments. */
  1554.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1555. {
  1556.     Interp *iPtr = (Interp *) interp;
  1557.     char *varName, *pattern, *simplePattern;
  1558.     register Tcl_HashEntry *entryPtr;
  1559.     Tcl_HashSearch search;
  1560.     Var *varPtr, *localVarPtr;
  1561.     Namespace *nsPtr;
  1562.     Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
  1563.     Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
  1564.     Tcl_Obj *listPtr, *elemObjPtr;
  1565.     int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */
  1566.     int i, result;
  1567.  
  1568.     /*
  1569.      * Get the pattern and find the "effective namespace" in which to
  1570.      * list variables. We only use this effective namespace if there's
  1571.      * no active Tcl procedure frame.
  1572.      */
  1573.  
  1574.     if (objc == 2) {
  1575.         simplePattern = NULL;
  1576.     nsPtr = currNsPtr;
  1577.     specificNsInPattern = 0;
  1578.     } else if (objc == 3) {
  1579.     /*
  1580.      * From the pattern, get the effective namespace and the simple
  1581.      * pattern (no namespace qualifiers or ::'s) at the end. If an
  1582.      * error was found while parsing the pattern, return it. Otherwise,
  1583.      * if the namespace wasn't found, just leave nsPtr NULL: we will
  1584.      * return an empty list since no variables there can be found.
  1585.      */
  1586.  
  1587.     Namespace *dummy1NsPtr, *dummy2NsPtr;
  1588.  
  1589.         pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  1590.     result = TclGetNamespaceForQualName(interp, pattern,
  1591.         (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG,
  1592.         &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
  1593.     if (result != TCL_OK) {
  1594.         return TCL_ERROR;
  1595.     }
  1596.     if (nsPtr != NULL) {    /* we successfully found the pattern's ns */
  1597.         specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
  1598.     }
  1599.     } else {
  1600.         Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
  1601.         return TCL_ERROR;
  1602.     }
  1603.  
  1604.     /*
  1605.      * If the namespace specified in the pattern wasn't found, just return.
  1606.      */
  1607.  
  1608.     if (nsPtr == NULL) {
  1609.     return TCL_OK;
  1610.     }
  1611.     
  1612.     listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  1613.     
  1614.     if ((iPtr->varFramePtr == NULL)
  1615.         || !iPtr->varFramePtr->isProcCallFrame
  1616.         || specificNsInPattern) {
  1617.     /*
  1618.      * There is no frame pointer, the frame pointer was pushed only
  1619.      * to activate a namespace, or we are in a procedure call frame
  1620.      * but a specific namespace was specified. Create a list containing
  1621.      * only the variables in the effective namespace's variable table.
  1622.      */
  1623.     
  1624.     entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
  1625.     while (entryPtr != NULL) {
  1626.         varPtr = (Var *) Tcl_GetHashValue(entryPtr);
  1627.         if (!TclIsVarUndefined(varPtr)
  1628.             || (varPtr->flags & VAR_NAMESPACE_VAR)) {
  1629.         varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
  1630.         if ((simplePattern == NULL)
  1631.                     || Tcl_StringMatch(varName, simplePattern)) {
  1632.             if (specificNsInPattern) {
  1633.             elemObjPtr = Tcl_NewObj();
  1634.             Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
  1635.                     elemObjPtr);
  1636.             } else {
  1637.             elemObjPtr = Tcl_NewStringObj(varName, -1);
  1638.             }
  1639.             Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
  1640.         }
  1641.         }
  1642.         entryPtr = Tcl_NextHashEntry(&search);
  1643.     }
  1644.  
  1645.     /*
  1646.      * If the effective namespace isn't the global :: namespace, and a
  1647.      * specific namespace wasn't requested in the pattern (i.e., the
  1648.      * pattern only specifies variable names), then add in all global ::
  1649.      * variables that match the simple pattern. Of course, add in only
  1650.      * those variables that aren't hidden by a variable in the effective
  1651.      * namespace.
  1652.      */
  1653.  
  1654.     if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
  1655.         entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
  1656.         while (entryPtr != NULL) {
  1657.         varPtr = (Var *) Tcl_GetHashValue(entryPtr);
  1658.         if (!TclIsVarUndefined(varPtr)
  1659.                 || (varPtr->flags & VAR_NAMESPACE_VAR)) {
  1660.             varName = Tcl_GetHashKey(&globalNsPtr->varTable,
  1661.                 entryPtr);
  1662.             if ((simplePattern == NULL)
  1663.                         || Tcl_StringMatch(varName, simplePattern)) {
  1664.             if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
  1665.                 Tcl_ListObjAppendElement(interp, listPtr,
  1666.                         Tcl_NewStringObj(varName, -1));
  1667.             }
  1668.             }
  1669.         }
  1670.         entryPtr = Tcl_NextHashEntry(&search);
  1671.         }
  1672.     }
  1673.     } else {
  1674.     /*
  1675.      * We're in a local call frame and no specific namespace was
  1676.      * specific. Create a list that starts with the compiled locals
  1677.      * (i.e. the ones stored in the call frame).
  1678.      */
  1679.  
  1680.     CallFrame *varFramePtr = iPtr->varFramePtr;
  1681.         int localVarCt = varFramePtr->numCompiledLocals;
  1682.     Tcl_HashTable *varTablePtr = varFramePtr->varTablePtr;
  1683.     
  1684.         for (i = 0, localVarPtr = iPtr->varFramePtr->compiledLocals;
  1685.                 i < localVarCt;
  1686.                 i++, localVarPtr++) {
  1687.             if (!TclIsVarUndefined(localVarPtr)) {
  1688.                 varName = localVarPtr->name;
  1689.                 if ((simplePattern == NULL)
  1690.                 || Tcl_StringMatch(varName, simplePattern)) {
  1691.                     Tcl_ListObjAppendElement(interp, listPtr,
  1692.                 Tcl_NewStringObj(varName, -1));
  1693.                 }
  1694.             }
  1695.         }
  1696.  
  1697.     /*
  1698.      * Now add in the variables in the call frame's variable hash
  1699.      * table (if one exists).
  1700.      */
  1701.  
  1702.     if (varTablePtr != NULL) {
  1703.         for (entryPtr = Tcl_FirstHashEntry(varTablePtr, &search);
  1704.             entryPtr != NULL;
  1705.             entryPtr = Tcl_NextHashEntry(&search)) {
  1706.         varPtr = (Var *) Tcl_GetHashValue(entryPtr);
  1707.         if (!TclIsVarUndefined(varPtr)) {
  1708.             varName = Tcl_GetHashKey(varTablePtr, entryPtr);
  1709.             if ((simplePattern == NULL)
  1710.                     || Tcl_StringMatch(varName, simplePattern)) {
  1711.             Tcl_ListObjAppendElement(interp, listPtr,
  1712.                 Tcl_NewStringObj(varName, -1));
  1713.             }
  1714.         }
  1715.         }
  1716.     }
  1717.     }
  1718.     
  1719.     Tcl_SetObjResult(interp, listPtr);
  1720.     return TCL_OK;
  1721. }
  1722.  
  1723. /*
  1724.  *----------------------------------------------------------------------
  1725.  *
  1726.  * Tcl_JoinObjCmd --
  1727.  *
  1728.  *    This procedure is invoked to process the "join" Tcl command.
  1729.  *    See the user documentation for details on what it does.
  1730.  *
  1731.  * Results:
  1732.  *    A standard Tcl object result.
  1733.  *
  1734.  * Side effects:
  1735.  *    See the user documentation.
  1736.  *
  1737.  *----------------------------------------------------------------------
  1738.  */
  1739.  
  1740.     /* ARGSUSED */
  1741. int
  1742. Tcl_JoinObjCmd(dummy, interp, objc, objv)
  1743.     ClientData dummy;        /* Not used. */
  1744.     Tcl_Interp *interp;        /* Current interpreter. */
  1745.     int objc;            /* Number of arguments. */
  1746.     Tcl_Obj *CONST objv[];    /* The argument objects. */
  1747. {
  1748.     char *joinString, *bytes;
  1749.     int joinLength, listLen, length, i, result;
  1750.     Tcl_Obj **elemPtrs;
  1751.  
  1752.     if (objc == 2) {
  1753.     joinString = " ";
  1754.     joinLength = 1;
  1755.     } else if (objc == 3) {
  1756.     joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
  1757.     } else {
  1758.     Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
  1759.     return TCL_ERROR;
  1760.     }
  1761.  
  1762.     /*
  1763.      * Make sure the list argument is a list object and get its length and
  1764.      * a pointer to its array of element pointers.
  1765.      */
  1766.  
  1767.     result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
  1768.     if (result != TCL_OK) {
  1769.     return result;
  1770.     }
  1771.  
  1772.     /*
  1773.      * Now concatenate strings to form the "joined" result. We append
  1774.      * directly into the interpreter's result object.
  1775.      */
  1776.  
  1777.     for (i = 0;  i < listLen;  i++) {
  1778.     bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
  1779.     if (i > 0) {
  1780.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), joinString,
  1781.             bytes, (char *) NULL);
  1782.     } else {
  1783.         Tcl_AppendToObj(Tcl_GetObjResult(interp), bytes, length);
  1784.     }
  1785.     }
  1786.     return TCL_OK;
  1787. }
  1788.  
  1789. /*
  1790.  *----------------------------------------------------------------------
  1791.  *
  1792.  * Tcl_LindexObjCmd --
  1793.  *
  1794.  *    This object-based procedure is invoked to process the "lindex" Tcl
  1795.  *    command. See the user documentation for details on what it does.
  1796.  *
  1797.  * Results:
  1798.  *    A standard Tcl object result.
  1799.  *
  1800.  * Side effects:
  1801.  *    See the user documentation.
  1802.  *
  1803.  *----------------------------------------------------------------------
  1804.  */
  1805.  
  1806.     /* ARGSUSED */
  1807. int
  1808. Tcl_LindexObjCmd(dummy, interp, objc, objv)
  1809.     ClientData dummy;        /* Not used. */
  1810.     Tcl_Interp *interp;        /* Current interpreter. */
  1811.     int objc;            /* Number of arguments. */
  1812.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1813. {
  1814.     Tcl_Obj *listPtr;
  1815.     Tcl_Obj **elemPtrs;
  1816.     int listLen, index, result;
  1817.  
  1818.     if (objc != 3) {
  1819.     Tcl_WrongNumArgs(interp, 1, objv, "list index");
  1820.     return TCL_ERROR;
  1821.     }
  1822.  
  1823.     /*
  1824.      * Convert the first argument to a list if necessary.
  1825.      */
  1826.  
  1827.     listPtr = objv[1];
  1828.     result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
  1829.     if (result != TCL_OK) {
  1830.     return result;
  1831.     }
  1832.  
  1833.     /*
  1834.      * Get the index from objv[2].
  1835.      */
  1836.  
  1837.     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
  1838.         &index);
  1839.     if (result != TCL_OK) {
  1840.     return result;
  1841.     }
  1842.     if ((index < 0) || (index >= listLen)) {
  1843.     /*
  1844.      * The index is out of range: the result is an empty string object.
  1845.      */
  1846.     
  1847.     return TCL_OK;
  1848.     }
  1849.  
  1850.     /*
  1851.      * Make sure listPtr still refers to a list object. It might have been
  1852.      * converted to an int above if the argument objects were shared.
  1853.      */
  1854.  
  1855.     if (listPtr->typePtr != &tclListType) {
  1856.     result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
  1857.             &elemPtrs);
  1858.     if (result != TCL_OK) {
  1859.         return result;
  1860.     }
  1861.     }
  1862.  
  1863.     /*
  1864.      * Set the interpreter's object result to the index-th list element.
  1865.      */
  1866.  
  1867.     Tcl_SetObjResult(interp, elemPtrs[index]);
  1868.     return TCL_OK;
  1869. }
  1870.  
  1871. /*
  1872.  *----------------------------------------------------------------------
  1873.  *
  1874.  * Tcl_LinsertObjCmd --
  1875.  *
  1876.  *    This object-based procedure is invoked to process the "linsert" Tcl
  1877.  *    command. See the user documentation for details on what it does.
  1878.  *
  1879.  * Results:
  1880.  *    A new Tcl list object formed by inserting zero or more elements 
  1881.  *    into a list.
  1882.  *
  1883.  * Side effects:
  1884.  *    See the user documentation.
  1885.  *
  1886.  *----------------------------------------------------------------------
  1887.  */
  1888.  
  1889.     /* ARGSUSED */
  1890. int
  1891. Tcl_LinsertObjCmd(dummy, interp, objc, objv)
  1892.     ClientData dummy;        /* Not used. */
  1893.     Tcl_Interp *interp;        /* Current interpreter. */
  1894.     register int objc;        /* Number of arguments. */
  1895.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  1896. {
  1897.     Tcl_Obj *listPtr, *resultPtr;
  1898.     int index, isDuplicate;
  1899.     int result;
  1900.  
  1901.     if (objc < 4) {
  1902.     Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
  1903.     return TCL_ERROR;
  1904.     }
  1905.  
  1906.     /*
  1907.      * Get the index first since, if a conversion to int is needed, it
  1908.      * will invalidate the list's internal representation.
  1909.      */
  1910.  
  1911.     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX,
  1912.         &index);
  1913.     if (result != TCL_OK) {
  1914.     return result;
  1915.     }
  1916.  
  1917.     /*
  1918.      * If the list object is unshared we can modify it directly. Otherwise
  1919.      * we create a copy to modify: this is "copy on write". We create the
  1920.      * duplicate directly in the interpreter's object result.
  1921.      */
  1922.     
  1923.     listPtr = objv[1];
  1924.     isDuplicate = 0;
  1925.     if (Tcl_IsShared(listPtr)) {
  1926.     Tcl_ResetResult(interp);
  1927.     resultPtr = Tcl_GetObjResult(interp);
  1928.     if (listPtr->typePtr != NULL) {
  1929.         Tcl_InvalidateStringRep(resultPtr);
  1930.         listPtr->typePtr->dupIntRepProc(listPtr, resultPtr);
  1931.     } else if (listPtr->bytes != NULL) {
  1932.         int len = listPtr->length;
  1933.         
  1934.         TclInitStringRep(resultPtr, listPtr->bytes, len);
  1935.     }
  1936.     listPtr = resultPtr;
  1937.     isDuplicate = 1;
  1938.     }
  1939.     
  1940.     if ((objc == 4) && (index == INT_MAX)) {
  1941.     /*
  1942.      * Special case: insert one element at the end of the list.
  1943.      */
  1944.  
  1945.     result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
  1946.     } else if (objc > 3) {
  1947.     result = Tcl_ListObjReplace(interp, listPtr, index, 0,
  1948.                     (objc-3), &(objv[3]));
  1949.     }
  1950.     if (result != TCL_OK) {
  1951.     return result;
  1952.     }
  1953.     
  1954.     /*
  1955.      * Set the interpreter's object result.
  1956.      */
  1957.  
  1958.     if (!isDuplicate) {
  1959.     Tcl_SetObjResult(interp, listPtr);
  1960.     }
  1961.     return TCL_OK;
  1962. }
  1963.  
  1964. /*
  1965.  *----------------------------------------------------------------------
  1966.  *
  1967.  * Tcl_ListObjCmd --
  1968.  *
  1969.  *    This procedure is invoked to process the "list" Tcl command.
  1970.  *    See the user documentation for details on what it does.
  1971.  *
  1972.  * Results:
  1973.  *    A standard Tcl object result.
  1974.  *
  1975.  * Side effects:
  1976.  *    See the user documentation.
  1977.  *
  1978.  *----------------------------------------------------------------------
  1979.  */
  1980.  
  1981.     /* ARGSUSED */
  1982. int
  1983. Tcl_ListObjCmd(dummy, interp, objc, objv)
  1984.     ClientData dummy;            /* Not used. */
  1985.     Tcl_Interp *interp;            /* Current interpreter. */
  1986.     register int objc;            /* Number of arguments. */
  1987.     register Tcl_Obj *CONST objv[];    /* The argument objects. */
  1988. {
  1989.     /*
  1990.      * If there are no list elements, the result is an empty object.
  1991.      * Otherwise modify the interpreter's result object to be a list object.
  1992.      */
  1993.     
  1994.     if (objc > 1) {
  1995.     Tcl_SetListObj(Tcl_GetObjResult(interp), (objc-1), &(objv[1]));
  1996.     }
  1997.     return TCL_OK;
  1998. }
  1999.  
  2000. /*
  2001.  *----------------------------------------------------------------------
  2002.  *
  2003.  * Tcl_LlengthObjCmd --
  2004.  *
  2005.  *    This object-based procedure is invoked to process the "llength" Tcl
  2006.  *    command.  See the user documentation for details on what it does.
  2007.  *
  2008.  * Results:
  2009.  *    A standard Tcl object result.
  2010.  *
  2011.  * Side effects:
  2012.  *    See the user documentation.
  2013.  *
  2014.  *----------------------------------------------------------------------
  2015.  */
  2016.  
  2017.     /* ARGSUSED */
  2018. int
  2019. Tcl_LlengthObjCmd(dummy, interp, objc, objv)
  2020.     ClientData dummy;            /* Not used. */
  2021.     Tcl_Interp *interp;            /* Current interpreter. */
  2022.     int objc;                /* Number of arguments. */
  2023.     register Tcl_Obj *CONST objv[];    /* Argument objects. */
  2024. {
  2025.     int listLen, result;
  2026.  
  2027.     if (objc != 2) {
  2028.     Tcl_WrongNumArgs(interp, 1, objv, "list");
  2029.     return TCL_ERROR;
  2030.     }
  2031.  
  2032.     result = Tcl_ListObjLength(interp, objv[1], &listLen);
  2033.     if (result != TCL_OK) {
  2034.     return result;
  2035.     }
  2036.  
  2037.     /*
  2038.      * Set the interpreter's object result to an integer object holding the
  2039.      * length. 
  2040.      */
  2041.  
  2042.     Tcl_SetIntObj(Tcl_GetObjResult(interp), listLen);
  2043.     return TCL_OK;
  2044. }
  2045.  
  2046. /*
  2047.  *----------------------------------------------------------------------
  2048.  *
  2049.  * Tcl_LrangeObjCmd --
  2050.  *
  2051.  *    This procedure is invoked to process the "lrange" Tcl command.
  2052.  *    See the user documentation for details on what it does.
  2053.  *
  2054.  * Results:
  2055.  *    A standard Tcl object result.
  2056.  *
  2057.  * Side effects:
  2058.  *    See the user documentation.
  2059.  *
  2060.  *----------------------------------------------------------------------
  2061.  */
  2062.  
  2063.     /* ARGSUSED */
  2064. int
  2065. Tcl_LrangeObjCmd(notUsed, interp, objc, objv)
  2066.     ClientData notUsed;            /* Not used. */
  2067.     Tcl_Interp *interp;            /* Current interpreter. */
  2068.     int objc;                /* Number of arguments. */
  2069.     register Tcl_Obj *CONST objv[];    /* Argument objects. */
  2070. {
  2071.     Tcl_Obj *listPtr;
  2072.     Tcl_Obj **elemPtrs;
  2073.     int listLen, first, last, numElems, result;
  2074.  
  2075.     if (objc != 4) {
  2076.     Tcl_WrongNumArgs(interp, 1, objv, "list first last");
  2077.     return TCL_ERROR;
  2078.     }
  2079.  
  2080.     /*
  2081.      * Make sure the list argument is a list object and get its length and
  2082.      * a pointer to its array of element pointers.
  2083.      */
  2084.  
  2085.     listPtr = objv[1];
  2086.     result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
  2087.     if (result != TCL_OK) {
  2088.     return result;
  2089.     }
  2090.  
  2091.     /*
  2092.      * Get the first and last indexes.
  2093.      */
  2094.  
  2095.     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
  2096.         &first);
  2097.     if (result != TCL_OK) {
  2098.     return result;
  2099.     }
  2100.     if (first < 0) {
  2101.     first = 0;
  2102.     }
  2103.  
  2104.     result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
  2105.         &last);
  2106.     if (result != TCL_OK) {
  2107.     return result;
  2108.     }
  2109.     if (last >= listLen) {
  2110.     last = (listLen - 1);
  2111.     }
  2112.     
  2113.     if (first > last) {
  2114.     return TCL_OK;        /* the result is an empty object */
  2115.     }
  2116.  
  2117.     /*
  2118.      * Make sure listPtr still refers to a list object. It might have been
  2119.      * converted to an int above if the argument objects were shared.
  2120.      */  
  2121.  
  2122.     if (listPtr->typePtr != &tclListType) {
  2123.         result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
  2124.                 &elemPtrs);
  2125.         if (result != TCL_OK) {
  2126.             return result;
  2127.         }
  2128.     }
  2129.  
  2130.     /*
  2131.      * Extract a range of fields. We modify the interpreter's result object
  2132.      * to be a list object containing the specified elements.
  2133.      */
  2134.  
  2135.     numElems = (last - first + 1);
  2136.     Tcl_SetListObj(Tcl_GetObjResult(interp), numElems, &(elemPtrs[first]));
  2137.     return TCL_OK;
  2138. }
  2139.  
  2140. /*
  2141.  *----------------------------------------------------------------------
  2142.  *
  2143.  * Tcl_LreplaceObjCmd --
  2144.  *
  2145.  *    This object-based procedure is invoked to process the "lreplace" 
  2146.  *    Tcl command. See the user documentation for details on what it does.
  2147.  *
  2148.  * Results:
  2149.  *    A new Tcl list object formed by replacing zero or more elements of
  2150.  *    a list.
  2151.  *
  2152.  * Side effects:
  2153.  *    See the user documentation.
  2154.  *
  2155.  *----------------------------------------------------------------------
  2156.  */
  2157.  
  2158.     /* ARGSUSED */
  2159. int
  2160. Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
  2161.     ClientData dummy;        /* Not used. */
  2162.     Tcl_Interp *interp;        /* Current interpreter. */
  2163.     int objc;            /* Number of arguments. */
  2164.     Tcl_Obj *CONST objv[];    /* Argument objects. */
  2165. {
  2166.     register Tcl_Obj *listPtr;
  2167.     int createdNewObj, first, last, listLen, numToDelete, result;
  2168.  
  2169.     if (objc < 4) {
  2170.     Tcl_WrongNumArgs(interp, 1, objv,
  2171.         "list first last ?element element ...?");
  2172.     return TCL_ERROR;
  2173.     }
  2174.  
  2175.     /*
  2176.      * If the list object is unshared we can modify it directly, otherwise
  2177.      * we create a copy to modify: this is "copy on write".
  2178.      */
  2179.     
  2180.     listPtr = objv[1];
  2181.     createdNewObj = 0;
  2182.     if (Tcl_IsShared(listPtr)) {
  2183.     listPtr = Tcl_DuplicateObj(listPtr);
  2184.     createdNewObj = 1;
  2185.     }
  2186.     result = Tcl_ListObjLength(interp, listPtr, &listLen);
  2187.     if (result != TCL_OK) {
  2188.         errorReturn:
  2189.     if (createdNewObj) {
  2190.         Tcl_DecrRefCount(listPtr); /* free unneeded obj */
  2191.     }
  2192.     return result;
  2193.     }
  2194.  
  2195.     /*
  2196.      * Get the first and last indexes.
  2197.      */
  2198.  
  2199.     result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
  2200.         &first);
  2201.     if (result != TCL_OK) {
  2202.     goto errorReturn;
  2203.     }
  2204.  
  2205.     result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
  2206.         &last);
  2207.     if (result != TCL_OK) {
  2208.     goto errorReturn;
  2209.     }
  2210.  
  2211.     if (first < 0)  {
  2212.         first = 0;
  2213.     }
  2214.     if (first >= listLen) {
  2215.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  2216.         "list doesn't contain element ",
  2217.         Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
  2218.     result = TCL_ERROR;
  2219.     goto errorReturn;
  2220.     }
  2221.     if (last >= listLen) {
  2222.         last = (listLen - 1);
  2223.     }
  2224.     if (first <= last) {
  2225.     numToDelete = (last - first + 1);
  2226.     } else {
  2227.     numToDelete = 0;
  2228.     }
  2229.  
  2230.     if (objc > 4) {
  2231.     result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
  2232.             (objc-4), &(objv[4]));
  2233.     } else {
  2234.     result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
  2235.         0, NULL);
  2236.     }
  2237.     if (result != TCL_OK) {
  2238.     goto errorReturn;
  2239.     }
  2240.  
  2241.     /*
  2242.      * Set the interpreter's object result. 
  2243.      */
  2244.  
  2245.     Tcl_SetObjResult(interp, listPtr);
  2246.     return TCL_OK;
  2247. }
  2248.  
  2249. /*
  2250.  *----------------------------------------------------------------------
  2251.  *
  2252.  * Tcl_LsearchObjCmd --
  2253.  *
  2254.  *    This procedure is invoked to process the "lsearch" Tcl command.
  2255.  *    See the user documentation for details on what it does.
  2256.  *
  2257.  * Results:
  2258.  *    A standard Tcl result.
  2259.  *
  2260.  * Side effects:
  2261.  *    See the user documentation.
  2262.  *
  2263.  *----------------------------------------------------------------------
  2264.  */
  2265.  
  2266. int
  2267. Tcl_LsearchObjCmd(clientData, interp, objc, objv)
  2268.     ClientData clientData;    /* Not used. */
  2269.     Tcl_Interp *interp;        /* Current interpreter. */
  2270.     int objc;            /* Number of arguments. */
  2271.     Tcl_Obj *CONST objv[];    /* Argument values. */
  2272. {
  2273. #define EXACT    0
  2274. #define GLOB    1
  2275. #define REGEXP    2
  2276.     char *bytes, *patternBytes;
  2277.     int i, match, mode, index, result, listLen, length, elemLen;
  2278.     Tcl_Obj **elemPtrs;
  2279.     static char *switches[] =
  2280.         {"-exact", "-glob", "-regexp", (char *) NULL};
  2281.  
  2282.     mode = GLOB;
  2283.     if (objc == 4) {
  2284.     if (Tcl_GetIndexFromObj(interp, objv[1], switches,
  2285.         "search mode", 0, &mode) != TCL_OK) {
  2286.         return TCL_ERROR;
  2287.     }
  2288.     } else if (objc != 3) {
  2289.     Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern");
  2290.     return TCL_ERROR;
  2291.     }
  2292.  
  2293.     /*
  2294.      * Make sure the list argument is a list object and get its length and
  2295.      * a pointer to its array of element pointers.
  2296.      */
  2297.  
  2298.     result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs);
  2299.     if (result != TCL_OK) {
  2300.     return result;
  2301.     }
  2302.  
  2303.     patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length);
  2304.  
  2305.     index = -1;
  2306.     for (i = 0; i < listLen; i++) {
  2307.     match = 0;
  2308.     bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
  2309.     switch (mode) {
  2310.         case EXACT:
  2311.         if (length == elemLen) {
  2312.             match = (memcmp(bytes, patternBytes,
  2313.                 (size_t) length) == 0);
  2314.         }
  2315.         break;
  2316.         case GLOB:
  2317.         /*
  2318.          * WARNING: will not work with data containing NULLs.
  2319.          */
  2320.         match = Tcl_StringMatch(bytes, patternBytes);
  2321.         break;
  2322.         case REGEXP:
  2323.         /*
  2324.          * WARNING: will not work with data containing NULLs.
  2325.          */
  2326.         match = Tcl_RegExpMatch(interp, bytes, patternBytes);
  2327.         if (match < 0) {
  2328.             return TCL_ERROR;
  2329.         }
  2330.         break;
  2331.     }
  2332.     if (match) {
  2333.         index = i;
  2334.         break;
  2335.     }
  2336.     }
  2337.  
  2338.     Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
  2339.     return TCL_OK;
  2340. }
  2341.  
  2342. /*
  2343.  *----------------------------------------------------------------------
  2344.  *
  2345.  * Tcl_LsortObjCmd --
  2346.  *
  2347.  *    This procedure is invoked to process the "lsort" Tcl command.
  2348.  *    See the user documentation for details on what it does.
  2349.  *
  2350.  * Results:
  2351.  *    A standard Tcl result.
  2352.  *
  2353.  * Side effects:
  2354.  *    See the user documentation.
  2355.  *
  2356.  *----------------------------------------------------------------------
  2357.  */
  2358.  
  2359. int
  2360. Tcl_LsortObjCmd(clientData, interp, objc, objv)
  2361.     ClientData clientData;    /* Not used. */
  2362.     Tcl_Interp *interp;        /* Current interpreter. */
  2363.     int objc;            /* Number of arguments. */
  2364.     Tcl_Obj *CONST objv[];    /* Argument values. */
  2365. {
  2366.     int i, index, dummy;
  2367.     Tcl_Obj *resultPtr;
  2368.     int length;
  2369.     Tcl_Obj *cmdPtr, **listObjPtrs;
  2370.     SortElement *elementArray;
  2371.     SortElement *elementPtr;        
  2372.     SortInfo sortInfo;                  /* Information about this sort that
  2373.                                          * needs to be passed to the 
  2374.                                          * comparison function */
  2375.     static char *switches[] =
  2376.         {"-ascii", "-command", "-decreasing", "-dictionary",
  2377.         "-increasing", "-index", "-integer", "-real", (char *) NULL};
  2378.  
  2379.     resultPtr = Tcl_GetObjResult(interp);
  2380.     if (objc < 2) {
  2381.     Tcl_WrongNumArgs(interp, 1, objv, "?options? list");
  2382.     return TCL_ERROR;
  2383.     }
  2384.  
  2385.     /*
  2386.      * Parse arguments to set up the mode for the sort.
  2387.      */
  2388.  
  2389.     sortInfo.isIncreasing = 1;
  2390.     sortInfo.sortMode = SORTMODE_ASCII;
  2391.     sortInfo.index = -1;
  2392.     sortInfo.interp = interp;
  2393.     sortInfo.resultCode = TCL_OK;
  2394.     cmdPtr = NULL;
  2395.     for (i = 1; i < objc-1; i++) {
  2396.     if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index)
  2397.         != TCL_OK) {
  2398.         return TCL_ERROR;
  2399.     }
  2400.     switch (index) {
  2401.         case 0:            /* -ascii */
  2402.         sortInfo.sortMode = SORTMODE_ASCII;
  2403.         break;
  2404.         case 1:            /* -command */
  2405.         if (i == (objc-2)) {
  2406.             Tcl_AppendToObj(resultPtr,
  2407.                 "\"-command\" option must be followed by comparison command",
  2408.                 -1);
  2409.             return TCL_ERROR;
  2410.         }
  2411.         sortInfo.sortMode = SORTMODE_COMMAND;
  2412.         cmdPtr = objv[i+1];
  2413.         i++;
  2414.         break;
  2415.         case 2:            /* -decreasing */
  2416.         sortInfo.isIncreasing = 0;
  2417.         break;
  2418.         case 3:            /* -dictionary */
  2419.         sortInfo.sortMode = SORTMODE_DICTIONARY;
  2420.         break;
  2421.         case 4:            /* -increasing */
  2422.         sortInfo.isIncreasing = 1;
  2423.         break;
  2424.         case 5:            /* -index */
  2425.         if (i == (objc-2)) {
  2426.             Tcl_AppendToObj(resultPtr,
  2427.                 "\"-index\" option must be followed by list index",
  2428.                 -1);
  2429.             return TCL_ERROR;
  2430.         }
  2431.         if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
  2432.             != TCL_OK) {
  2433.             return TCL_ERROR;
  2434.         }
  2435.         cmdPtr = objv[i+1];
  2436.         i++;
  2437.         break;
  2438.         case 6:            /* -integer */
  2439.         sortInfo.sortMode = SORTMODE_INTEGER;
  2440.         break;
  2441.         case 7:            /* -real */
  2442.         sortInfo.sortMode = SORTMODE_REAL;
  2443.         break;
  2444.     }
  2445.     }
  2446.     if (sortInfo.sortMode == SORTMODE_COMMAND) {
  2447.     Tcl_DStringInit(&sortInfo.compareCmd);
  2448.     Tcl_DStringAppend(&sortInfo.compareCmd,
  2449.         Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
  2450.     }
  2451.  
  2452.     sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
  2453.         &length, &listObjPtrs);
  2454.     if (sortInfo.resultCode != TCL_OK) {
  2455.     goto done;
  2456.     }
  2457.     if (length <= 0) {
  2458.         return TCL_OK;
  2459.     }
  2460.     elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
  2461.     for (i=0; i < length; i++){
  2462.     elementArray[i].objPtr = listObjPtrs[i];
  2463.     elementArray[i].nextPtr = &elementArray[i+1];
  2464.     }
  2465.     elementArray[length-1].nextPtr = NULL;
  2466.     elementPtr = MergeSort(elementArray, &sortInfo);
  2467.     if (sortInfo.resultCode == TCL_OK) {
  2468.     /*
  2469.      * Note: must clear the interpreter's result object: it could
  2470.      * have been set by the -command script.
  2471.      */
  2472.  
  2473.     Tcl_ResetResult(interp);
  2474.     resultPtr = Tcl_GetObjResult(interp);
  2475.     for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
  2476.         Tcl_ListObjAppendElement(interp, resultPtr, elementPtr->objPtr);
  2477.     }
  2478.     }
  2479.     ckfree((char*) elementArray);
  2480.  
  2481.     done:
  2482.     if (sortInfo.sortMode == SORTMODE_COMMAND) {
  2483.     Tcl_DStringFree(&sortInfo.compareCmd);
  2484.     }
  2485.     return sortInfo.resultCode;
  2486. }
  2487.  
  2488. /*
  2489.  *----------------------------------------------------------------------
  2490.  *
  2491.  * MergeSort -
  2492.  *
  2493.  *    This procedure sorts a linked list of SortElement structures
  2494.  *    use the merge-sort algorithm.
  2495.  *
  2496.  * Results:
  2497.  *      A pointer to the head of the list after sorting is returned.
  2498.  *
  2499.  * Side effects:
  2500.  *    None, unless a user-defined comparison command does something
  2501.  *    weird.
  2502.  *
  2503.  *----------------------------------------------------------------------
  2504.  */
  2505.  
  2506. static SortElement *
  2507. MergeSort(headPtr, infoPtr)
  2508.     SortElement *headPtr;               /* First element on the list */
  2509.     SortInfo *infoPtr;                  /* Information needed by the
  2510.                                          * comparison operator */
  2511. {
  2512.     /*
  2513.      * The subList array below holds pointers to temporary lists built
  2514.      * during the merge sort.  Element i of the array holds a list of
  2515.      * length 2**i.
  2516.      */
  2517.  
  2518. #   define NUM_LISTS 30
  2519.     SortElement *subList[NUM_LISTS];
  2520.     SortElement *elementPtr;
  2521.     int i;
  2522.  
  2523.     for(i = 0; i < NUM_LISTS; i++){
  2524.         subList[i] = NULL;
  2525.     }
  2526.     while (headPtr != NULL) {
  2527.     elementPtr = headPtr;
  2528.     headPtr = headPtr->nextPtr;
  2529.     elementPtr->nextPtr = 0;
  2530.     for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
  2531.         elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
  2532.         subList[i] = NULL;
  2533.     }
  2534.     if (i >= NUM_LISTS) {
  2535.         i = NUM_LISTS-1;
  2536.     }
  2537.     subList[i] = elementPtr;
  2538.     }
  2539.     elementPtr = NULL;
  2540.     for (i = 0; i < NUM_LISTS; i++){
  2541.         elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
  2542.     }
  2543.     return elementPtr;
  2544. }
  2545.  
  2546. /*
  2547.  *----------------------------------------------------------------------
  2548.  *
  2549.  * MergeLists -
  2550.  *
  2551.  *    This procedure combines two sorted lists of SortElement structures
  2552.  *    into a single sorted list.
  2553.  *
  2554.  * Results:
  2555.  *      The unified list of SortElement structures.
  2556.  *
  2557.  * Side effects:
  2558.  *    None, unless a user-defined comparison command does something
  2559.  *    weird.
  2560.  *
  2561.  *----------------------------------------------------------------------
  2562.  */
  2563.  
  2564. static SortElement *
  2565. MergeLists(leftPtr, rightPtr, infoPtr)
  2566.     SortElement *leftPtr;               /* First list to be merged; may be
  2567.                      * NULL. */
  2568.     SortElement *rightPtr;              /* Second list to be merged; may be
  2569.                      * NULL. */
  2570.     SortInfo *infoPtr;                  /* Information needed by the
  2571.                                          * comparison operator. */
  2572. {
  2573.     SortElement *headPtr;
  2574.     SortElement *tailPtr;
  2575.  
  2576.     if (leftPtr == NULL) {
  2577.         return rightPtr;
  2578.     }
  2579.     if (rightPtr == NULL) {
  2580.         return leftPtr;
  2581.     }
  2582.     if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
  2583.     tailPtr = rightPtr;
  2584.     rightPtr = rightPtr->nextPtr;
  2585.     } else {
  2586.     tailPtr = leftPtr;
  2587.     leftPtr = leftPtr->nextPtr;
  2588.     }
  2589.     headPtr = tailPtr;
  2590.     while ((leftPtr != NULL) && (rightPtr != NULL)) {
  2591.     if (SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr) > 0) {
  2592.         tailPtr->nextPtr = rightPtr;
  2593.         tailPtr = rightPtr;
  2594.         rightPtr = rightPtr->nextPtr;
  2595.     } else {
  2596.         tailPtr->nextPtr = leftPtr;
  2597.         tailPtr = leftPtr;
  2598.         leftPtr = leftPtr->nextPtr;
  2599.     }
  2600.     }
  2601.     if (leftPtr != NULL) {
  2602.        tailPtr->nextPtr = leftPtr;
  2603.     } else {
  2604.        tailPtr->nextPtr = rightPtr;
  2605.     }
  2606.     return headPtr;
  2607. }
  2608.  
  2609. /*
  2610.  *----------------------------------------------------------------------
  2611.  *
  2612.  * SortCompare --
  2613.  *
  2614.  *    This procedure is invoked by MergeLists to determine the proper
  2615.  *    ordering between two elements.
  2616.  *
  2617.  * Results:
  2618.  *      A negative results means the the first element comes before the
  2619.  *      second, and a positive results means that the second element
  2620.  *      should come first.  A result of zero means the two elements
  2621.  *      are equal and it doesn't matter which comes first.
  2622.  *
  2623.  * Side effects:
  2624.  *    None, unless a user-defined comparison command does something
  2625.  *    weird.
  2626.  *
  2627.  *----------------------------------------------------------------------
  2628.  */
  2629.  
  2630. static int
  2631. SortCompare(objPtr1, objPtr2, infoPtr)
  2632.     Tcl_Obj *objPtr1, *objPtr2;        /* Values to be compared. */
  2633.     SortInfo *infoPtr;                  /* Information passed from the
  2634.                                          * top-level "lsort" command */
  2635. {
  2636.     int order, dummy, listLen, index;
  2637.     Tcl_Obj *objPtr;
  2638.     char buffer[30];
  2639.  
  2640.     order = 0;
  2641.     if (infoPtr->resultCode != TCL_OK) {
  2642.     /*
  2643.      * Once an error has occurred, skip any future comparisons
  2644.      * so as to preserve the error message in sortInterp->result.
  2645.      */
  2646.  
  2647.     return order;
  2648.     }
  2649.     if (infoPtr->index != -1) {
  2650.     /*
  2651.      * The "-index" option was specified.  Treat each object as a
  2652.      * list, extract the requested element from each list, and
  2653.      * compare the elements, not the lists.  The special index "end"
  2654.      * is signaled here with a large negative index.
  2655.      */
  2656.  
  2657.     if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
  2658.         infoPtr->resultCode = TCL_ERROR;
  2659.         return order;
  2660.     }
  2661.     if (infoPtr->index < -1) {
  2662.         index = listLen - 1;
  2663.     } else {
  2664.         index = infoPtr->index;
  2665.     }
  2666.  
  2667.     if (Tcl_ListObjIndex(infoPtr->interp, objPtr1, index, &objPtr)
  2668.         != TCL_OK) {
  2669.         infoPtr->resultCode = TCL_ERROR;
  2670.         return order;
  2671.     }
  2672.     if (objPtr == NULL) {
  2673.         objPtr = objPtr1;
  2674.         missingElement:
  2675.         sprintf(buffer, "%d", infoPtr->index);
  2676.         Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
  2677.             "element ", buffer, " missing from sublist \"",
  2678.             Tcl_GetStringFromObj(objPtr, (int *) NULL),
  2679.             "\"", (char *) NULL);
  2680.         infoPtr->resultCode = TCL_ERROR;
  2681.         return order;
  2682.     }
  2683.     objPtr1 = objPtr;
  2684.  
  2685.     if (Tcl_ListObjLength(infoPtr->interp, objPtr2, &listLen) != TCL_OK) {
  2686.         infoPtr->resultCode = TCL_ERROR;
  2687.         return order;
  2688.     }
  2689.     if (infoPtr->index < -1) {
  2690.         index = listLen - 1;
  2691.     } else {
  2692.         index = infoPtr->index;
  2693.     }
  2694.  
  2695.     if (Tcl_ListObjIndex(infoPtr->interp, objPtr2, index, &objPtr)
  2696.         != TCL_OK) {
  2697.         infoPtr->resultCode = TCL_ERROR;
  2698.         return order;
  2699.     }
  2700.     if (objPtr == NULL) {
  2701.         objPtr = objPtr2;
  2702.         goto missingElement;
  2703.     }
  2704.     objPtr2 = objPtr;
  2705.     }
  2706.     if (infoPtr->sortMode == SORTMODE_ASCII) {
  2707.     order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
  2708.         Tcl_GetStringFromObj(objPtr2, &dummy));
  2709.     } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
  2710.     order = DictionaryCompare(
  2711.         Tcl_GetStringFromObj(objPtr1, &dummy),
  2712.         Tcl_GetStringFromObj(objPtr2, &dummy));
  2713.     } else if (infoPtr->sortMode == SORTMODE_INTEGER) {
  2714.     int a, b;
  2715.  
  2716.     if ((Tcl_GetIntFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
  2717.         || (Tcl_GetIntFromObj(infoPtr->interp, objPtr2, &b)
  2718.         != TCL_OK)) {
  2719.         infoPtr->resultCode = TCL_ERROR;
  2720.         return order;
  2721.     }
  2722.     if (a > b) {
  2723.         order = 1;
  2724.     } else if (b > a) {
  2725.         order = -1;
  2726.     }
  2727.     } else if (infoPtr->sortMode == SORTMODE_REAL) {
  2728.     double a, b;
  2729.  
  2730.     if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK)
  2731.           || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b)
  2732.               != TCL_OK)) {
  2733.         infoPtr->resultCode = TCL_ERROR;
  2734.         return order;
  2735.     }
  2736.     if (a > b) {
  2737.         order = 1;
  2738.     } else if (b > a) {
  2739.         order = -1;
  2740.     }
  2741.     } else {
  2742.     int oldLength;
  2743.  
  2744.     /*
  2745.      * Generate and evaluate a command to determine which string comes
  2746.      * first.
  2747.      */
  2748.  
  2749.     oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
  2750.     Tcl_DStringAppendElement(&infoPtr->compareCmd,
  2751.         Tcl_GetStringFromObj(objPtr1, &dummy));
  2752.     Tcl_DStringAppendElement(&infoPtr->compareCmd,
  2753.         Tcl_GetStringFromObj(objPtr2, &dummy));
  2754.     infoPtr->resultCode = Tcl_Eval(infoPtr->interp, 
  2755.         Tcl_DStringValue(&infoPtr->compareCmd));
  2756.     Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
  2757.     if (infoPtr->resultCode != TCL_OK) {
  2758.         Tcl_AddErrorInfo(infoPtr->interp,
  2759.             "\n    (-compare command)");
  2760.         return order;
  2761.     }
  2762.  
  2763.     /*
  2764.      * Parse the result of the command.
  2765.      */
  2766.  
  2767.     if (Tcl_GetIntFromObj(infoPtr->interp,
  2768.         Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
  2769.         Tcl_ResetResult(infoPtr->interp);
  2770.         Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
  2771.             "-compare command returned non-numeric result", -1);
  2772.         infoPtr->resultCode = TCL_ERROR;
  2773.         return order;
  2774.     }
  2775.     }
  2776.     if (!infoPtr->isIncreasing) {
  2777.     order = -order;
  2778.     }
  2779.     return order;
  2780. }
  2781.  
  2782. /*
  2783.  *----------------------------------------------------------------------
  2784.  *
  2785.  * DictionaryCompare
  2786.  *
  2787.  *    This function compares two strings as if they were being used in
  2788.  *    an index or card catalog.  The case of alphabetic characters is
  2789.  *    ignored, except to break ties.  Thus "B" comes before "b" but
  2790.  *    after "a".  Also, integers embedded in the strings compare in
  2791.  *    numerical order.  In other words, "x10y" comes after "x9y", not
  2792.  *      before it as it would when using strcmp().
  2793.  *
  2794.  * Results:
  2795.  *      A negative result means that the first element comes before the
  2796.  *      second, and a positive result means that the second element
  2797.  *      should come first.  A result of zero means the two elements
  2798.  *      are equal and it doesn't matter which comes first.
  2799.  *
  2800.  * Side effects:
  2801.  *    None.
  2802.  *
  2803.  *----------------------------------------------------------------------
  2804.  */
  2805.  
  2806. static int
  2807. DictionaryCompare(left, right)
  2808.     char *left, *right;          /* The strings to compare */
  2809. {
  2810.     int diff, zeros;
  2811.     int secondaryDiff = 0;
  2812.  
  2813.     while (1) {
  2814.     if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
  2815.         /*
  2816.          * There are decimal numbers embedded in the two
  2817.          * strings.  Compare them as numbers, rather than
  2818.          * strings.  If one number has more leading zeros than
  2819.          * the other, the number with more leading zeros sorts
  2820.          * later, but only as a secondary choice.
  2821.          */
  2822.  
  2823.         zeros = 0;
  2824.         while (*right == '0') {
  2825.         right++;
  2826.         zeros--;
  2827.         }
  2828.         while (*left == '0') {
  2829.         left++;
  2830.         zeros++;
  2831.         }
  2832.         if (secondaryDiff == 0) {
  2833.         secondaryDiff = zeros;
  2834.         }
  2835.  
  2836.         /*
  2837.          * The code below compares the numbers in the two
  2838.          * strings without ever converting them to integers.  It
  2839.          * does this by first comparing the lengths of the
  2840.          * numbers and then comparing the digit values.
  2841.          */
  2842.  
  2843.         diff = 0;
  2844.         while (1) {
  2845.         if (diff == 0) {
  2846.             diff = *left - *right;
  2847.         }
  2848.         right++;
  2849.         left++;
  2850.         if (!isdigit(UCHAR(*right))) {
  2851.             if (isdigit(UCHAR(*left))) {
  2852.             return 1;
  2853.             } else {
  2854.             /*
  2855.              * The two numbers have the same length. See
  2856.              * if their values are different.
  2857.              */
  2858.  
  2859.             if (diff != 0) {
  2860.                 return diff;
  2861.             }
  2862.             break;
  2863.             }
  2864.         } else if (!isdigit(UCHAR(*left))) {
  2865.             return -1;
  2866.         }
  2867.         }
  2868.         continue;
  2869.     }
  2870.         diff = *left - *right;
  2871.         if (diff) {
  2872.             if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
  2873.                 diff = tolower(*left) - *right;
  2874.                 if (diff) {
  2875.             return diff;
  2876.                 } else if (secondaryDiff == 0) {
  2877.             secondaryDiff = -1;
  2878.                 }
  2879.             } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
  2880.                 diff = *left - tolower(UCHAR(*right));
  2881.                 if (diff) {
  2882.             return diff;
  2883.                 } else if (secondaryDiff == 0) {
  2884.             secondaryDiff = 1;
  2885.                 }
  2886.             } else {
  2887.                 return diff;
  2888.             }
  2889.         }
  2890.         if (*left == 0) {
  2891.         break;
  2892.     }
  2893.         left++;
  2894.         right++;
  2895.     }
  2896.     if (diff == 0) {
  2897.     diff = secondaryDiff;
  2898.     }
  2899.     return diff;
  2900. }
  2901.